;; generic/method.scm - (c) rohan drape, 2003-2005

;; Predicates.  Untyped arguments are of type <Any>.

(define any?    (lambda (x) #t))
(define Any?    any?)
(define Int?    integer?)
(define Real?   real?)
(define Number? number?)
(define Num?    number?)
(define String? string?)
(define Char?   char?)
(define List?   list?)
(define Vector? vector?)
(define Symbol? symbol?)
(define Stream? stream?)

;; The <method> type.  A method consists of a list of one argument
;; predicate functions and an application function.

(define-structure method (predicates function))

;; Syntax to convert a symbolic type notation <type> to the predicate
;; type?.  Other values are passed unchanged.

(define-syntax process-method-qualifier
  (lambda (x)
    (define (transform-symbol t)
      (datum->syntax-object
       t
       (let* ((d (syntax-object->datum t))
	      (s (symbol->string d))
	      (l (string-length s))
	      (b (string-ref s 0))
	      (e (string-ref s (- l 1))))
	 (if (and (eq? b #\<) (eq? e #\>))
	     (string->symbol (string-append (substring s 1 (- l 1)) "?"))
	     d))))
    (syntax-case x ()
      ((_ name)
       (let ((d (syntax-object->datum x)))
	 (and (list? d) (not (symbol? (cadr d)))))
       #'name)
      ((_ name) (transform-symbol #'name)))))

;; Construct a <method> given a list of typed arguments and a list
;; expression.

(define-syntax make-normal-method
  (syntax-rules ()
    ((_ ((name qualifier) ...) body ...)
     (make-method (map (lambda (e) (if (unary-function? e)
					e
					(lambda (value) (equal? e value))))
			(list (process-method-qualifier qualifier) ...))
		   (lambda (name ...) body ...)))))

;; A <method-table> is a <box> holding a <list>.

(define (make-method-table)
  (box (list)))

;; Add a <method> to the <method-table> of the generic `name'.

(define (method-table-put! name method)
  (let ((b (generic-method-table name)))
    (set-box! b (cons method (unbox b)))))
  
;; Dispatch `arguments' against all methods in the <method-table> `b'.

(define (method-table-dispatch b arguments)

  ;; Find congruent method for `arguments' in the list of `methods'.
  ;; Raise an error if there is no congruent method.

  (define (make-dispatch methods arguments)

    ;; Returns '#t' iff all `arguments' satisfy all `predicates', and
    ;; there is an identical number of each.  If there are no
    ;; arguments and no predicates the method is congruent.

    (define (is-congruent? predicates arguments)
      (cond ((and (null? predicates) (null? arguments))
	     #t)
	    ((or (null? predicates) (null? arguments))
	     #f)
	    (else 
	     (and ((car predicates) (car arguments))
		  (is-congruent? (cdr predicates) (cdr arguments))))))

    (if (null? methods)
	(error "No congruent method" arguments)
	(let ((method (car methods)))
	  (if (is-congruent? (method-predicates method) arguments)
	      (apply (method-function method) arguments)
	      (make-dispatch (cdr methods) arguments)))))

  (make-dispatch (unbox b) arguments))

;; Add a method to the global table.  This *does not* implicitly
;; define the generic.

(define-syntax define-method
  (syntax-rules ()
    ((_ (name) body ...)
     (method-table-put! 
      'name
      (make-normal-method () body ...)))
    ((_ (name (argument type) ...) body ...)
     (method-table-put!
      'name 
      (make-normal-method ((argument type) ...) body ...)))))

